home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / mwexpand.scm < prev    next >
Text File  |  1999-04-19  |  18KB  |  566 lines
  1. ;"mwexpand.scm" macro expander
  2. ; Copyright 1992 William Clinger
  3. ;
  4. ; Permission to copy this software, in whole or in part, to use this
  5. ; software for any lawful purpose, and to redistribute this software
  6. ; is granted subject to the restriction that all copies made of this
  7. ; software must include this copyright notice in full.
  8. ;
  9. ; I also request that you send me a copy of any improvements that you
  10. ; make to this software so that they may be incorporated within it to
  11. ; the benefit of the Scheme community.
  12.  
  13. ; The external entry points and kernel of the macro expander.
  14. ;
  15. ; Part of this code is snarfed from the Twobit macro expander.
  16.  
  17. (define mw:define-syntax-scope
  18.   (let ((flag 'letrec))
  19.     (lambda args
  20.       (cond ((null? args) flag)
  21.         ((not (null? (cdr args)))
  22.          (apply mw:warn
  23.             "Too many arguments passed to define-syntax-scope"
  24.             args))
  25.         ((memq (car args) '(letrec letrec* let*))
  26.          (set! flag (car args)))
  27.         (else (mw:warn "Unrecognized argument to define-syntax-scope"
  28.               (car args)))))))
  29.  
  30. (define mw:quit             ; assigned by macwork:expand
  31.   (lambda (v) v))
  32.  
  33. (define (macwork:expand def-or-exp)
  34.   (call-with-current-continuation
  35.    (lambda (k)
  36.      (set! mw:quit k)
  37.      (set! mw:renaming-counter 0)
  38.      (mw:desugar-definitions def-or-exp mw:global-syntax-environment))))
  39.  
  40. (define (mw:desugar-definitions exp env)
  41.   (letrec 
  42.     ((define-loop 
  43.        (lambda (exp rest first)
  44.      (cond ((and (pair? exp)
  45.              (eq? (mw:syntax-lookup env (car exp))
  46.               mw:denote-of-begin)
  47.              (pair? (cdr exp)))
  48.         (define-loop (cadr exp) (append (cddr exp) rest) first))
  49.            ((and (pair? exp)
  50.              (eq? (mw:syntax-lookup env (car exp))
  51.               mw:denote-of-define))
  52.         (let ((exp (desugar-define exp env)))
  53.           (cond ((and (null? first) (null? rest))
  54.              exp)
  55.             ((null? rest)
  56.              (cons mw:begin1 (reverse (cons exp first))))
  57.             (else (define-loop (car rest)
  58.                        (cdr rest)
  59.                        (cons exp first))))))
  60.            ((and (pair? exp)
  61.              (eq? (mw:syntax-lookup env (car exp))
  62.               mw:denote-of-define-syntax)
  63.              (null? first))
  64.         (define-syntax-loop exp rest))
  65.            ((and (null? first) (null? rest))
  66.         (mw:expand exp env))
  67.            ((null? rest)
  68.         (cons mw:begin1 (reverse (cons (mw:expand exp env) first))))
  69.            (else (cons mw:begin1
  70.                (append (reverse first)
  71.                    (map (lambda (exp) (mw:expand exp env))
  72.                     (cons exp rest))))))))
  73.      
  74.      (desugar-define
  75.       (lambda (exp env)
  76.     (cond 
  77.      ((null? (cdr exp)) (mw:error "Malformed definition" exp))
  78.      ; (define foo) syntax is transformed into (define foo (undefined)).
  79.      ((null? (cddr exp))
  80.       (let ((id (cadr exp)))
  81.         (redefinition id)
  82.         (mw:syntax-bind-globally! id (mw:make-identifier-denotation id))
  83.         (list mw:define1 id mw:undefined)))
  84.      ((pair? (cadr exp))
  85.       ; mw:lambda0 is an unforgeable lambda, needed here because the
  86.       ; lambda expression will undergo further expansion.
  87.       (desugar-define `(,mw:define1 ,(car (cadr exp))
  88.                      (,mw:lambda0 ,(cdr (cadr exp))
  89.                            ,@(cddr exp)))
  90.               env))
  91.      ((> (length exp) 3) (mw:error "Malformed definition" exp))
  92.      (else (let ((id (cadr exp)))
  93.          (redefinition id)
  94.          (mw:syntax-bind-globally! id (mw:make-identifier-denotation id))
  95.          `(,mw:define1 ,id ,(mw:expand (caddr exp) env)))))))
  96.      
  97.      (define-syntax-loop 
  98.        (lambda (exp rest)
  99.      (cond ((and (pair? exp)
  100.              (eq? (mw:syntax-lookup env (car exp))
  101.               mw:denote-of-begin)
  102.              (pair? (cdr exp)))
  103.         (define-syntax-loop (cadr exp) (append (cddr exp) rest)))
  104.            ((and (pair? exp)
  105.              (eq? (mw:syntax-lookup env (car exp))
  106.               mw:denote-of-define-syntax))
  107.         (if (pair? (cdr exp))
  108.             (redefinition (cadr exp)))
  109.         (if (null? rest)
  110.             (mw:define-syntax exp env)
  111.             (begin (mw:define-syntax exp env)
  112.                (define-syntax-loop (car rest) (cdr rest)))))
  113.            ((null? rest)
  114.         (mw:expand exp env))
  115.            (else (cons mw:begin1
  116.                (map (lambda (exp) (mw:expand exp env))
  117.                     (cons exp rest)))))))
  118.      
  119.      (redefinition
  120.       (lambda (id)
  121.     (if (symbol? id)
  122.         (if (not (mw:identifier?
  123.               (mw:syntax-lookup mw:global-syntax-environment id)))
  124.         (mw:warn "Redefining keyword" id))
  125.         (mw:error "Malformed variable or keyword" id)))))
  126.     
  127.     ; body of letrec
  128.     
  129.     (define-loop exp '() '())))
  130.  
  131. ; Given an expression and a syntactic environment,
  132. ; returns an expression in core Scheme.
  133.  
  134. (define (mw:expand exp env)
  135.   (if (not (pair? exp))
  136.       (mw:atom exp env)
  137.       (let ((keyword (mw:syntax-lookup env (car exp))))
  138.     (case (mw:denote-class keyword)
  139.       ((special)
  140.        (cond
  141.         ((eq? keyword mw:denote-of-quote)         (mw:quote exp))
  142.         ((eq? keyword mw:denote-of-lambda)        (mw:lambda exp env))
  143.         ((eq? keyword mw:denote-of-if)            (mw:if exp env))
  144.         ((eq? keyword mw:denote-of-set!)          (mw:set exp env))
  145.         ((eq? keyword mw:denote-of-begin)         (mw:begin exp env))
  146.         ((eq? keyword mw:denote-of-let-syntax)    (mw:let-syntax exp env))
  147.         ((eq? keyword mw:denote-of-letrec-syntax)
  148.          (mw:letrec-syntax exp env))
  149.      ; @@ case has a nontrivial syntax also -- wdc
  150.      ((eq? keyword mw:denote-of-case)          (mw:case   exp env))
  151.         ; @@ let, let*, letrec, paint within quasiquotation -- kend
  152.         ((eq? keyword mw:denote-of-let)           (mw:let    exp env))
  153.         ((eq? keyword mw:denote-of-let*)          (mw:let*   exp env))
  154.         ((eq? keyword mw:denote-of-letrec)        (mw:letrec exp env))
  155.         ((eq? keyword mw:denote-of-quasiquote)    (mw:quasiquote exp env))
  156.         ((eq? keyword mw:denote-of-do)            (mw:do     exp env))
  157.         ((or (eq? keyword mw:denote-of-define)
  158.          (eq? keyword mw:denote-of-define-syntax))
  159.          ;; slight hack to allow expansion into defines -KenD
  160.          (if mw:in-define? 
  161.            (mw:error "Definition out of context" exp)
  162.            (begin
  163.          (set! mw:in-define? #t)
  164.          (let ( (result (mw:desugar-definitions exp env)) )
  165.            (set! mw:in-define? #f)
  166.            result))
  167.         ))
  168.         (else (mw:bug "Bug detected in mw:expand" exp env))))
  169.       ((macro) (mw:macro exp env))
  170.       ((identifier) (mw:application exp env))
  171.       (else (mw:bug "Bug detected in mw:expand" exp env))
  172.       ) )
  173. ) )
  174.  
  175. (define mw:in-define? #f)  ; should be fluid
  176.  
  177. (define (mw:atom exp env)
  178.   (cond ((not (symbol? exp))
  179.      ; Here exp ought to be a boolean, number, character, or string,
  180.      ; but I'll allow for non-standard extensions by passing exp
  181.      ; to the underlying Scheme system without further checking.
  182.      exp)
  183.     (else (let ((denotation (mw:syntax-lookup env exp)))
  184.         (case (mw:denote-class denotation)
  185.           ((special macro)
  186.            (mw:error "Syntactic keyword used as a variable" exp env))
  187.           ((identifier) (mw:identifier-name denotation))
  188.           (else (mw:bug "Bug detected by mw:atom" exp env)))))))
  189.  
  190. (define (mw:quote exp)
  191.   (if (= (mw:safe-length exp) 2)
  192.       (list mw:quote1 (mw:strip (cadr exp)))
  193.       (mw:error "Malformed quoted constant" exp)))
  194.  
  195. (define (mw:lambda exp env)
  196.   (if (> (mw:safe-length exp) 2)
  197.       (let* ((formals (cadr exp))
  198.          (alist (mw:rename-vars (mw:make-null-terminated formals)))
  199.          (env (mw:syntax-rename env alist))
  200.          (body (cddr exp)))
  201.     (list mw:lambda1
  202.           (mw:rename-formals formals alist)
  203.           (mw:body body env)))
  204.       (mw:error "Malformed lambda expression" exp)))
  205.  
  206. (define (mw:body body env)
  207.   (define (loop body env defs)
  208.     (if (null? body)
  209.     (mw:error "Empty body"))
  210.     (let ((exp (car body)))
  211.       (if (and (pair? exp)
  212.            (symbol? (car exp)))
  213.       (let ((denotation (mw:syntax-lookup env (car exp))))
  214.         (case (mw:denote-class denotation)
  215.           ((special)
  216.            (cond ((eq? denotation mw:denote-of-begin)
  217.               (loop (append (cdr exp) (cdr body)) env defs))
  218.              ((eq? denotation mw:denote-of-define)
  219.               (loop (cdr body) env (cons exp defs)))
  220.              (else (mw:finalize-body body env defs))))
  221.           ((macro)
  222.            (mw:transcribe exp
  223.                  env
  224.                  (lambda (exp env)
  225.                    (loop (cons exp (cdr body))
  226.                      env
  227.                      defs))))
  228.           ((identifier)
  229.            (mw:finalize-body body env defs))
  230.           (else (mw:bug "Bug detected in mw:body" body env))))
  231.       (mw:finalize-body body env defs))))
  232.   (loop body env '()))
  233.  
  234. (define (mw:finalize-body body env defs)
  235.   (if (null? defs)
  236.       (let ((body (map (lambda (exp) (mw:expand exp env))
  237.                body)))
  238.     (if (null? (cdr body))
  239.         (car body)
  240.         (cons mw:begin1 body)))
  241.       (let* ((alist (mw:rename-vars '(quote lambda set!)))
  242.          (env (mw:syntax-alias env alist mw:standard-syntax-environment))
  243.          (new-quote  (cdr (assq 'quote alist)))
  244.          (new-lambda (cdr (assq 'lambda alist)))
  245.          (new-set!   (cdr (assq 'set!   alist))))
  246.     (define (desugar-definition def)
  247.       (if (> (mw:safe-length def) 2)
  248.           (cond ((pair? (cadr def))
  249.              (desugar-definition
  250.               `(,(car def)
  251.             ,(car (cadr def))
  252.             (,new-lambda
  253.               ,(cdr (cadr def))
  254.               ,@(cddr def)))))
  255.             ((= (length def) 3)
  256.              (cdr def))
  257.             (else (mw:error "Malformed definition" def env)))
  258.           (mw:error "Malformed definition" def env)))
  259.     (mw:letrec
  260.      `(letrec ,(map desugar-definition (reverse defs)) ,@body)
  261.       env)))
  262.   )
  263.  
  264. (define (mw:if exp env)
  265.   (let ((n (mw:safe-length exp)))
  266.     (if (or (= n 3) (= n 4))
  267.     (cons mw:if1 (map (lambda (exp) (mw:expand exp env)) (cdr exp)))
  268.     (mw:error "Malformed if expression" exp env))))
  269.  
  270. (define (mw:set exp env)
  271.   (if (= (mw:safe-length exp) 3)
  272.       `(,mw:set!1 ,(mw:expand (cadr exp) env) ,(mw:expand (caddr exp) env))
  273.       (mw:error "Malformed assignment" exp env)))
  274.  
  275. (define (mw:begin exp env)
  276.   (if (positive? (mw:safe-length exp))
  277.       `(,mw:begin1 ,@(map (lambda (exp) (mw:expand exp env)) (cdr exp)))
  278.       (mw:error "Malformed begin expression" exp env)))
  279.  
  280. (define (mw:application exp env)
  281.   (if (> (mw:safe-length exp) 0)
  282.       (map (lambda (exp) (mw:expand exp env))
  283.        exp)
  284.       (mw:error "Malformed application")))
  285.  
  286. ; I think the environment argument should always be global here.
  287.  
  288. (define (mw:define-syntax exp env)
  289.   (cond ((and (= (mw:safe-length exp) 3)
  290.           (symbol? (cadr exp)))
  291.      (mw:define-syntax1 (cadr exp)
  292.                (caddr exp)
  293.                env
  294.                (mw:define-syntax-scope)))
  295.     ((and (= (mw:safe-length exp) 4)
  296.           (symbol? (cadr exp))
  297.           (memq (caddr exp) '(letrec letrec* let*)))
  298.      (mw:define-syntax1 (cadr exp)
  299.                (cadddr exp)
  300.                env
  301.                (caddr exp)))
  302.     (else (mw:error "Malformed define-syntax" exp env))))
  303.  
  304. (define (mw:define-syntax1 keyword spec env scope)
  305.   (case scope
  306.     ((letrec)  (mw:define-syntax-letrec keyword spec env))
  307.     ((letrec*) (mw:define-syntax-letrec* keyword spec env))
  308.     ((let*)    (mw:define-syntax-let* keyword spec env))
  309.     (else      (mw:bug "Weird scope" scope)))
  310.   (list mw:quote1 keyword))
  311.  
  312. (define (mw:define-syntax-letrec keyword spec env)
  313.   (mw:syntax-bind-globally!
  314.    keyword
  315.    (mw:compile-transformer-spec spec env)))
  316.  
  317. (define (mw:define-syntax-letrec* keyword spec env)
  318.   (let* ((env (mw:syntax-extend (mw:syntax-copy env)
  319.                 (list keyword)
  320.                 '((fake denotation))))
  321.      (transformer (mw:compile-transformer-spec spec env)))
  322.     (mw:syntax-assign! env keyword transformer)
  323.     (mw:syntax-bind-globally! keyword transformer)))
  324.  
  325. (define (mw:define-syntax-let* keyword spec env)
  326.   (mw:syntax-bind-globally!
  327.    keyword
  328.    (mw:compile-transformer-spec spec (mw:syntax-copy env))))
  329.  
  330. (define (mw:let-syntax exp env)
  331.   (if (and (> (mw:safe-length exp) 2)
  332.        (comlist:every (lambda (binding)
  333.             (and (pair? binding)
  334.              (symbol? (car binding))
  335.              (pair? (cdr binding))
  336.              (null? (cddr binding))))
  337.             (cadr exp)))
  338.       (mw:body (cddr exp)
  339.           (mw:syntax-extend env
  340.                 (map car (cadr exp))
  341.                 (map (lambda (spec)
  342.                        (mw:compile-transformer-spec
  343.                     spec
  344.                     env))
  345.                      (map cadr (cadr exp)))))
  346.       (mw:error "Malformed let-syntax" exp env)))
  347.  
  348. (define (mw:letrec-syntax exp env)
  349.   (if (and (> (mw:safe-length exp) 2)
  350.        (comlist:every (lambda (binding)
  351.             (and (pair? binding)
  352.              (symbol? (car binding))
  353.              (pair? (cdr binding))
  354.              (null? (cddr binding))))
  355.             (cadr exp)))
  356.       (let ((env (mw:syntax-extend env
  357.                    (map car (cadr exp))
  358.                    (map (lambda (id)
  359.                       '(fake denotation))
  360.                     (cadr exp)))))
  361.     (for-each (lambda (id spec)
  362.             (mw:syntax-assign!
  363.              env
  364.              id
  365.              (mw:compile-transformer-spec spec env)))
  366.           (map car (cadr exp))
  367.           (map cadr (cadr exp)))
  368.     (mw:body (cddr exp) env))
  369.       (mw:error "Malformed let-syntax" exp env)))
  370.  
  371. (define (mw:macro exp env)
  372.   (mw:transcribe exp
  373.         env
  374.         (lambda (exp env)
  375.           (mw:expand exp env))))
  376.  
  377. ; To do:
  378. ; Clean up alist hacking et cetera.
  379.  
  380. ;;-----------------------------------------------------------------
  381. ;; The following was added to allow expansion without flattening 
  382. ;; LETs to LAMBDAs so that the origianl structure of the program 
  383. ;; is preserved by macro expansion.  I.e. so that usual.scm is not 
  384. ;; required. -- added KenD 
  385.  
  386. (define (mw:process-let-bindings alist binding-list env)  ;; helper proc
  387.   (map (lambda (bind)
  388.      (list (cdr (assq (car bind) alist)) ; renamed name
  389.            (mw:body (cdr bind) env)))     ; alpha renamed value expression
  390.        binding-list)
  391. )
  392.  
  393. (define (mw:strip-begin exp) ;; helper proc: mw:body sometimes puts one in
  394.   (if (and (pair? exp) (eq? (car exp) 'begin))
  395.     (cdr exp)
  396.     exp)
  397. )
  398.  
  399. ; CASE -- added by wdc
  400. (define (mw:case exp env)
  401.   (let ((expand (lambda (exp)
  402.                   (mw:expand exp env))))
  403.     (if (< (mw:safe-length exp) 3)
  404.         (mw:error "Malformed case expression" exp env)
  405.         `(case ,(expand (cadr exp))
  406.                ,@(map (lambda (clause)
  407.                         (if (< (mw:safe-length exp) 2)
  408.                             (mw:error "Malformed case clause" exp env)
  409.                             (cons (mw:strip (car clause))
  410.                                   (map expand (cdr clause)))))
  411.                       (cddr exp))))))
  412.  
  413.  
  414. ; LET
  415. (define (mw:let exp env)
  416.   (let* ( (name (if (or (pair? (cadr exp)) (null? (cadr exp)))
  417.             #f 
  418.             (cadr exp)))  ; named let?
  419.       (binds (if name (caddr exp) (cadr exp)))
  420.       (body  (if name (cdddr exp) (cddr exp)))
  421.       (vars  (if (null? binds) #f (map car binds)))
  422.       (alist (if vars (mw:rename-vars vars) #f))
  423.       (newenv (if alist (mw:syntax-rename env alist) env))
  424.     )
  425.     (if name  ;; extend env with new name
  426.     (let ( (rename (mw:rename-vars (list name))) )
  427.       (set! alist (append rename alist))
  428.       (set! newenv (mw:syntax-rename newenv rename))
  429.     )   )
  430.     `(let
  431.      ,@(if name (list (cdr (assq name alist))) '())
  432.      ,(mw:process-let-bindings alist binds env)
  433.      ,(mw:body body newenv))
  434. ) )
  435.  
  436.  
  437. ; LETREC differs from LET in that the binding values are processed in the
  438. ; new rather than the original environment.
  439.  
  440. (define (mw:letrec exp env)
  441.   (let* ( (binds (cadr exp))
  442.       (body  (cddr exp))
  443.       (vars  (if (null? binds) #f (map car binds)))
  444.       (alist (if vars (mw:rename-vars vars) #f))
  445.       (newenv (if alist (mw:syntax-rename env alist) env))
  446.     )
  447.     `(letrec
  448.       ,(mw:process-let-bindings alist binds newenv)
  449.       ,(mw:body body newenv))
  450. ) )
  451.  
  452.  
  453. ; LET* adds to ENV for each new binding.
  454.  
  455. (define (mw:let* exp env)
  456.   (let ( (binds (cadr exp))
  457.      (body  (cddr exp))
  458.        )
  459.     (let bind-loop ( (bindings binds) (newbinds '()) (newenv env) )
  460.        (if (null? bindings)
  461.       `(let* ,(reverse newbinds) ,(mw:body body newenv))
  462.        (let* ( (bind (car bindings))
  463.            (var    (car bind)) 
  464.            (valexp (cdr bind))
  465.            (rename (mw:rename-vars (list var)))
  466.            (next-newenv (mw:syntax-rename newenv rename))
  467.          )
  468.          (bind-loop (cdr bindings) 
  469.             (cons (list (cdr (assq var rename))
  470.                     (mw:body valexp newenv))
  471.                   newbinds)
  472.             next-newenv))
  473. ) ) ) )
  474.  
  475.  
  476. ; DO
  477.  
  478. (define (mw:process-do-bindings var-init-steps alist oldenv newenv)  ;; helper proc
  479.   (map (lambda (vis)
  480.      (let ( (v (car vis))
  481.         (i (cadr vis))
  482.         (s (if (null? (cddr vis)) (car vis) (caddr vis))))
  483.        `( ,(cdr (assq v alist)) ; renamed name
  484.           ,(mw:body (list i) oldenv)     ; init in outer/old env
  485.           ,(mw:body (list s) newenv) ))) ; step in letrec/inner/new env
  486.        var-init-steps)
  487. )
  488.  
  489. (define (mw:do exp env)
  490.   (let* ( (vis  (cadr exp))  ; (Var Init Step ...)
  491.       (ts   (caddr exp)) ; (Test Sequence ...)
  492.       (com  (cdddr exp)) ; (COMmand ...)
  493.       (vars (if (null? vis) #f (map car vis)))
  494.       (rename (if vars (mw:rename-vars vars) #f))
  495.       (newenv (if vars (mw:syntax-rename env rename) env))
  496.     )
  497.     `(do ,(if vars (mw:process-do-bindings vis rename env newenv) '())
  498.      ,(if  (null? ts)  '() (mw:strip-begin (mw:body (list ts) newenv)))
  499.      ,@(if (null? com) '() (list (mw:body com newenv))))
  500. ) )
  501.  
  502. ;
  503. ; Quasiquotation (backquote)           
  504. ;
  505. ; At level 0, unquoted forms are left painted (not mw:strip'ed).
  506. ; At higher levels, forms which are unquoted to level 0 are painted.
  507. ; This includes forms within quotes.  E.g.:
  508. ;   (lambda (a) 
  509. ;     (quasiquote 
  510. ;       (a (unquote a) b (quasiquote (a (unquote (unquote a)) b)))))
  511. ;or equivalently:
  512. ;  (lambda (a) `(a ,a b `(a ,,a b)))
  513. ;=>
  514. ;  (lambda (a|1) `(a ,a|1 b `(a ,,a|1 b)))
  515.  
  516. (define (mw:quasiquote exp env)
  517.  
  518.   (define (mw:atom exp env)
  519.     (if (not (symbol? exp))
  520.     exp
  521.     (let ((denotation (mw:syntax-lookup env exp)))
  522.       (case (mw:denote-class denotation)
  523.         ((special macro identifier) (mw:identifier-name denotation))
  524.         (else (mw:bug "Bug detected by mw:atom" exp env))))
  525.   ) )
  526.  
  527.   (define (quasi subexp level)
  528.      (cond
  529.     ((null? subexp) subexp)
  530.     ((not (or (pair? subexp) (vector? subexp)))
  531.      (if (zero? level) (mw:atom subexp env) subexp) ; the work is here
  532.     )
  533.     ((vector? subexp)
  534.      (let* ((l (vector-length subexp))
  535.         (v (make-vector l)))
  536.        (do ((i 0 (+ i 1)))
  537.            ((= i l) v)
  538.          (vector-set! v i (quasi (vector-ref subexp i) level))
  539.          )
  540.        )
  541.      )
  542.     (else
  543.       (let ( (keyword (mw:syntax-lookup env (car subexp))) )
  544.         (cond
  545.           ((eq? keyword mw:denote-of-unquote)
  546.            (cons 'unquote (quasi (cdr subexp) (- level 1)))
  547.           )
  548.           ((eq? keyword mw:denote-of-unquote-splicing)
  549.            (cons 'unquote-splicing (quasi (cdr subexp) (- level 1)))
  550.           )
  551.           ((eq? keyword mw:denote-of-quasiquote)
  552.            (cons 'quasiquote (quasi (cdr subexp) (+ level 1)))
  553.           )
  554.           (else 
  555.            (cons (quasi (car subexp) level) (quasi (cdr subexp) level)) 
  556.           )
  557.         )
  558.     ) ) ; end else, let
  559.      ) ; end cond 
  560.   )
  561.  
  562.   (quasi exp 0) ; need to unquote to level 0 to paint
  563. )
  564.  
  565. ;;                                      --- E O F ---
  566.